home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / command.lisp < prev    next >
Lisp/Scheme  |  1992-05-26  |  19KB  |  541 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package "CLIO-OPEN")
  23.  
  24. (export '(make-command
  25.       command
  26.       command-area
  27.       command-control-area
  28.       command-default-accept
  29.       command-default-cancel
  30.       dialog-default-control 
  31.       ))
  32.  
  33.  
  34. (defconstant *default-accept-label*  "OK")
  35. (defconstant *default-cancel-label*  "Cancel")
  36.  
  37. ;;;----------------------------------------------------------------------------+
  38. ;;;                                                                            |
  39. ;;;                                  command                                   |
  40. ;;;                                                                            |
  41. ;;;----------------------------------------------------------------------------+
  42.  
  43.  
  44. (defcontact command (core core-wm-shell transient-shell)
  45.   ((previous-pointer-x
  46.                     :type (or null int16)
  47.             :initform nil)
  48.    (previous-pointer-y
  49.                     :type (or null int16)
  50.             :initform nil)
  51.    (control-default :type (or null contact)
  52.             :initform nil))
  53.   (:resources
  54.     (border-width    :initform 1)
  55.     (command-area    :type (or function list) :initform nil)
  56.     (control-area    :type (or function list) :initform nil)
  57.     (default-accept  :type (or (member :on :off) string)
  58.                      :initform :on)
  59.     (default-cancel  :type (or (member :on :off) string)
  60.                      :initform :on)
  61.     (default-control :type symbol :initform nil))
  62.   
  63.   (:documentation "A dialog which presents a set of related values and a set of commands."))
  64.  
  65.  
  66. (defmethod (setf contact-foreground) :after (new-value (self command))
  67.   (setf (contact-foreground (car (composite-children self))) new-value))
  68.  
  69. (defun make-command (&rest initargs &key &allow-other-keys)
  70.   "Creates and returns a command instance."
  71.   (declare (values command)) 
  72.   (apply #'make-contact 'command initargs))
  73.  
  74.  
  75. (defmethod command-area ((self  command))
  76.   "Returns the command area of the COMMAND."
  77.   (with-slots (children) (first (slot-value self 'children))
  78.     (find :area children :key #'contact-name)))
  79.  
  80.  
  81. (defmethod command-control-area ((self  command))
  82.   "Returns the command control of the COMMAND."
  83.   (with-slots (children) (first (slot-value self 'children))
  84.     (find :control children :key #'contact-name)))
  85.   
  86.  
  87. (defmethod dialog-accept ((self command))
  88.   "Invokes :accept callback function and pops down the dialogue"
  89.   (if (callback-p self :accept)
  90.       (apply-callback self :accept)
  91.       (with-slots ((members children)) (command-area self)
  92.     (dolist (member members)
  93.       (apply-callback member :accept))))
  94.   (with-slots (pinned-p) self
  95.     (unless pinned-p (setf (contact-state self) :withdrawn))))
  96.  
  97.  
  98. (defmethod dialog-cancel ((self command))
  99.   "Invokes :cancel callback function and pops down the dialogue."
  100.   (with-slots (pinned-p) self
  101.     (unless pinned-p (setf (contact-state self) :withdrawn)))
  102.   (if (callback-p self :cancel)
  103.       (apply-callback self :cancel)
  104.       (with-slots ((members children)) (command-area self)
  105.     (dolist (member members)
  106.       (apply-callback member :cancel)))))
  107.  
  108.  
  109. (defmethod shell-mapped ((self command))
  110.   "Invokes :initialize callback function."
  111.   (with-slots (children) self
  112.     (setf (display-text-source (find :footer (composite-children (first children)) :key 'contact-name))
  113.       "")
  114.     (apply-callback self :map)
  115.     (apply-callback-else (self :initialize)
  116.       (with-slots ((members children)) (command-area self)
  117.     (dolist (member members)
  118.       (apply-callback member :initialize))))))
  119.  
  120. (defmethod (setf contact-state) :after ((new-state (eql :mapped)) (self command))
  121.   ;; Pointer warping must occur after :map-notify received, in case root-relative
  122.   ;; positions have been changed by window manager redirection.
  123.   
  124.  
  125.   (with-slots (previous-pointer-x previous-pointer-y display control-default) self
  126.     (let ((control-def (or control-default
  127.                    (first (composite-children (command-control-area self))))))
  128.       ;; Ensure realized.
  129.       (cond ((realized-p self)
  130.          ;; Store position for pointer unwarping later....
  131.          (multiple-value-setq
  132.            (previous-pointer-x previous-pointer-y) (pointer-position self))
  133.          
  134.          (warp-pointer
  135.            control-def
  136.            (pixel-round (contact-width control-def)  2)
  137.            (- (contact-height control-def) 2)))
  138.         ;; Ensure realized.
  139.         (t (update-state display))) 
  140.       )))
  141.  
  142. (defmethod shell-unmapped :before ((self command))
  143.   (with-slots (previous-pointer-x previous-pointer-y) self
  144.     ;; Unwarp pointer to original position, if necessary.
  145.     (when previous-pointer-x
  146.       (warp-pointer self previous-pointer-x previous-pointer-y))))
  147.  
  148.  
  149. (defmethod dialog-warn ((self command) message field)
  150.   "Display a warning for verification error."
  151.   (assert (or (null field) (typep field 'contact)) nil "~s is not a contact." field)
  152.   (let* ((footer (find :footer (composite-children (car (composite-children self)))
  153.                   :key #'contact-name))
  154.      (actual-message (or message "These values cannot be accepted."))
  155.      (tw  (text-width (display-text-font footer) actual-message)))
  156.     (if (>= tw (contact-width footer))
  157.     (confirm-p
  158.       :message     actual-message
  159.       :near        (or field (slot-value self 'control-default))
  160.       :parent      self
  161.       :accept-only :on)
  162.     (setf (display-text-source footer) actual-message))))
  163.  
  164. (eval-when (compile load eval)
  165.  
  166. (defun find-default-accept (command)               
  167.   (find :accept (composite-children (command-control-area command))
  168.     :key #'contact-name
  169.     :test #'eq))
  170.  
  171. (defun find-default-cancel (command)
  172.   (find :cancel (composite-children (command-control-area command))
  173.     :key #'contact-name
  174.     :test #'eq))
  175.  
  176. (defun command-verify (command)  
  177.   (multiple-value-bind (verified-p message field)
  178.       (or (not (callback-p command :verify))
  179.       (apply-callback command :verify))
  180.     (if verified-p
  181.     (dialog-accept command)    
  182.     (dialog-warn command message field))))
  183.   
  184. (defmethod command-default-accept ((self command))
  185.   (let ((control (find-default-accept self)))
  186.     (if (and control (eq (contact-state control) :mapped))
  187.     :on
  188.     :off)))
  189.   
  190. (defmethod command-default-cancel ((self command))
  191.   (let ((control (find-default-cancel self)))
  192.     (if (and control (eq (contact-state control) :mapped))
  193.     :on
  194.     :off)))
  195.   
  196. (defmethod (setf command-default-accept) (new-value (self command))
  197.   (check-type new-value (or (member :on :off) string) "one of :ON, :OFF, or a string.")
  198.   (let ((control (find-default-accept self)))
  199.     (case new-value
  200.       (:on
  201.        (if control
  202.        (setf (contact-state control) :mapped)
  203.        (add-callback (make-action-button
  204.               :parent (command-control-area self)
  205.               :name   :accept
  206.               :label  *default-accept-label*)
  207.              :release #'command-verify self)))
  208.       (:off
  209.        (when control
  210.      (setf (contact-state control) :withdrawn)))
  211.     
  212.       (otherwise
  213.        (cond
  214.      (control
  215.       (setf (button-label control) new-value)
  216.       (setf (contact-state control) :mapped))
  217.  
  218.      (t
  219.       (add-callback (make-action-button
  220.              :parent (command-control-area self)
  221.              :name   :accept
  222.              :label  new-value)
  223.             :release #'command-verify self))))))
  224.   new-value)
  225.  
  226. (defmethod (setf command-default-cancel) (new-value (self command))
  227.   (check-type new-value (or (member :on :off) string) "one of :ON, :OFF, or a string.")
  228.   (let ((control (find-default-cancel self)))
  229.     (case new-value
  230.       (:on
  231.        (if control
  232.        (setf (contact-state control) :mapped)
  233.        (add-callback (make-action-button
  234.               :parent (command-control-area self)
  235.               :name   :cancel
  236.               :label  *default-cancel-label*)
  237.              :release #'dialog-cancel self)))
  238.       (:off
  239.        (when control
  240.      (setf (contact-state control) :withdrawn)))
  241.     
  242.       (otherwise
  243.        (cond
  244.      (control
  245.       (setf (button-label control) new-value)
  246.       (setf (contact-state control) :mapped))
  247.  
  248.      (t
  249.       (add-callback (make-action-button
  250.              :parent (command-control-area self)
  251.              :name   :cancel
  252.              :label  new-value)
  253.             :release #'dialog-cancel self))))))
  254.   new-value)
  255.  
  256. (defmethod dialog-default-control ((self command))
  257.   (with-slots (control-default)
  258.     self
  259.     (let ((default (or control-default
  260.                (first (composite-children (command-control-area self))))))
  261.       (when default (contact-name default)))))
  262.  
  263.  
  264. (defmethod (setf dialog-default-control) (new-value (command command))
  265.   (check-type new-value symbol)
  266.   (with-slots (control-default)
  267.     command
  268.     (when control-default
  269.       (setf (choice-item-highlight-default-p control-default) nil))
  270.     (or (and (setf control-default
  271.            (find-if #'(lambda (c)
  272.                 (and (mapped-p c) (eq new-value (contact-name c))))
  273.                 (composite-children (command-control-area command))))
  274.          (setf (choice-item-highlight-default-p control-default) t))
  275.     (setf control-default new-value))
  276.     new-value)))
  277.  
  278.  
  279.  
  280.  
  281. (defmethod initialize-instance :after ((self command)
  282.                        &key
  283.                        command-area control-area
  284.                        default-accept default-cancel
  285.                        default-control
  286.                        &allow-other-keys)
  287.   (multiple-value-bind (command-constructor command-area-initargs)
  288.       (etypecase command-area
  289.     (null
  290.      (let ((space (ab-height (getf *button-dimensions-by-scale* (contact-scale self)))))
  291.        (values 'make-table 
  292.            `(
  293.              :columns              2
  294.              :column-alignment     :right
  295.              :same-width-in-column :on
  296.              :same-height-in-row   :on
  297.              :horizontal-space     ,space
  298.              :vertical-space       ,space))))
  299.  
  300.     (function command-area)
  301.  
  302.     (list (values (first command-area) (rest command-area))))
  303.       
  304.     (multiple-value-bind (control-constructor control-area-initargs)
  305.     (etypecase control-area
  306.       (null
  307.        (let ((space (point-pixels
  308.               (contact-screen self)
  309.               (getf *dialog-point-spacing* (contact-scale self)))))
  310.          (values 'make-table 
  311.              `(
  312.                :columns              :maximum
  313.                :column-alignment     :center
  314.                :same-height-in-row   :on
  315.                :horizontal-space     ,space
  316.                :vertical-space       ,space))))
  317.       
  318.       (function control-area)
  319.       
  320.       (list (values (first control-area) (rest control-area)))) 
  321.       
  322.       (with-slots (width height) self
  323.     
  324.     ;; Create the sheet
  325.     (let ((sheet (make-contact 'command-sheet :name :sheet
  326.                    :parent self
  327.                    :x 0 :y 0
  328.                    :width width :height height
  329.                    :border-width 0)))
  330.       
  331.       ;; Create the command area
  332.       (assert (typep (apply command-constructor :name :area
  333.                 :parent sheet
  334.                 :x 0 :y 0
  335.                 :width width :height height
  336.                 :border-width 0 command-area-initargs)
  337.              'composite) nil
  338.           "Command area is not a composite.")
  339.       
  340.       ;; Create the control area
  341.       (assert (typep (apply control-constructor :name :control
  342.                 :parent sheet
  343.                 :x 0 :y 0
  344.                 :width width :height height
  345.                 :border-width 0 control-area-initargs)
  346.              'composite) nil
  347.           "Control area is not a composite.")
  348.           
  349.       (add-event
  350.         (command-control-area self)
  351.         :enter-notify
  352.         #'(lambda (controls)
  353.         (with-slots (parent) (the contact (contact-parent controls))
  354.           (with-slots (previous-pointer-x) (the command parent)
  355.             (with-event (kind)
  356.               ;; Entering from a child? The first time this happens the child must be
  357.               ;; the default control. Open Look GUI thus dictates that pointer will not
  358.               ;; warp to original position after exiting the command
  359.               (when (eq kind :inferior)
  360.             (setf previous-pointer-x nil)))))))
  361.       
  362.       ;; Create footer area - display-text-field
  363.       (make-display-text-field :parent sheet :name :footer
  364.                    :source " " :alignment :left
  365.                    :display-gravity :west)
  366.       
  367.       ;; Create default controls
  368.       (setf (command-default-accept  self)  default-accept)
  369.       (setf (command-default-cancel  self)  default-cancel)
  370.       (when default-control
  371.         (setf (dialog-default-control self)  default-control)
  372.       ))))))
  373.  
  374.  
  375. ;;;----------------------------------------------------------------------------+
  376. ;;;                                                                            |
  377. ;;;;                               command-sheet                               |
  378. ;;;                                                                            |
  379. ;;;----------------------------------------------------------------------------+
  380.  
  381.  
  382. (defcontact command-sheet (core composite)
  383.   ((compress-exposures :initform :on))
  384.   (:resources (event-mask :initform #.(make-event-mask :exposure)))
  385.   (:documentation "The geometry manager for command and control areas."))
  386.  
  387.  
  388. (defmethod change-layout ((self command-sheet) &optional newly-managed)
  389.   (declare (ignore newly-managed))
  390.   (with-slots (width height parent) self
  391.  
  392.     ;; Initialize default control instance, if necessary.
  393.     (with-slots (control-default) parent
  394.       (let*
  395.     ((controls (composite-children (command-control-area parent)))
  396.      (instance (cond
  397.              ((null control-default)
  398.               (first controls))
  399.              
  400.              ((symbolp control-default)
  401.               (find control-default controls :key #'contact-name)))))
  402.     (when instance
  403.       (setf (choice-item-highlight-default-p (setf control-default instance)) t))))
  404.     
  405.     ;; Ensure big enough for command/control areas if possible.
  406.     (multiple-value-bind (pw ph) (preferred-size self)
  407.       
  408.       ;; Let window mgr know new preferred minimum height.
  409.       (with-wm-properties (parent)
  410.     (setf (wm-min-width  parent) pw
  411.           (wm-min-height parent) ph))
  412.       
  413.       (let ((rw (when (< width pw) pw))
  414.         (rh (when (< height ph) ph)))
  415.     
  416.     (when
  417.       (or
  418.         ;; Don't need to request larger size?
  419.         (not (or rw rh))
  420.         
  421.         ;; Request for larger size rejected?
  422.         (multiple-value-bind (approved-p nx ny nw nh)
  423.         (change-geometry self :width rw :height rh :accept-p t)
  424.           (declare (ignore nx ny))
  425.           (and (not approved-p) (eql nw width) (eql nh height))))
  426.       
  427.       ;; Yes, adjust child layout for current size.
  428.       (adjust-layout self))))))
  429.  
  430.  
  431. (defmethod adjust-layout ((self command-sheet))
  432.   (with-slots (width height children) self
  433.     (let*
  434.       ((space         (point-pixels
  435.             (contact-screen self)
  436.             (getf *dialog-point-spacing*
  437.                   (contact-scale (contact-parent self)))))
  438.        
  439.        (control-area (find :control children :key #'contact-name))
  440.        (command-area (find :area children :key #'contact-name)) 
  441.        
  442.        (footer        (find :footer children :key #'contact-name))
  443.        (footer-height (contact-height footer)))
  444.       
  445.       ;; Adjust footer geometry.
  446.       (resize footer width footer-height (contact-border-width footer))
  447.       (move footer 0 (- height footer-height))
  448.  
  449.       ;; Adjust control area geometry: preferred size if possible, but
  450.       ;; no more than available width and no more than half available height.
  451.       (multiple-value-bind (pw ph) (preferred-size control-area :width 0 :height 0)
  452.     (let* ((caw (min (- width space space) pw))
  453.            (avh (- height footer-height 1))
  454.            (cah (min (pixel-round avh 2) ph))
  455.            (cay (- avh cah space)))
  456.       (resize control-area caw cah 0)
  457.       (move control-area (max space (pixel-round (- width caw) 2)) cay)
  458.       
  459.       
  460.       ;; Adjust command area geometry: preferred size if possible, but
  461.       ;; no more than available space.
  462.       (multiple-value-bind (pw ph) (preferred-size command-area :width 0 :height 0)
  463.         (let ((caw (min (- width space space) pw))
  464.           (cah (min (- cay space space) ph)))
  465.           (resize command-area caw cah 0)
  466.       
  467.           ;;Center command-area within available space.
  468.           (move command-area
  469.             (max space (pixel-round (- width caw) 2))
  470.             (max space (pixel-round (- cay cah) 2))))))))))
  471.  
  472.  
  473. (defmethod display ((manager command-sheet) &optional x y width height &key)
  474.   (declare (ignore x y height width))
  475.   (with-slots (width height children foreground) manager
  476.     (let ((footer (find :footer children :key 'contact-name)))
  477.       (using-gcontext (gcontext :drawable manager :background (contact-current-background-pixel manager)
  478.                 :foreground foreground :subwindow-mode :include-inferiors)
  479.     (draw-rectangle manager gcontext 0 0
  480.             (max 1 (1- width))
  481.             (max 1 (- height (contact-height footer) 1))
  482.             )
  483.     ))))
  484.  
  485.  
  486. (defmethod manage-geometry ((command-sheet command-sheet) (child  contact)
  487.                 x y width height border-width &key)
  488.   (let (success-p)
  489.     (if (or 
  490.         
  491.         (and width  (> width  (contact-width child)))
  492.         (and height (> height (contact-height child)))
  493.         )
  494.     (setf success-p #'(lambda (command-sheet)
  495.                 (multiple-value-bind (p-w p-h p-b-w)
  496.                 (preferred-size command-sheet)
  497.                   (change-geometry command-sheet
  498.                            :width p-w
  499.                            :height p-h
  500.                            :border-width p-b-w
  501.                            :accept-p t))))
  502.       ;; else...
  503.       (setf success-p t))
  504.     
  505.     (values success-p
  506.         (or x (contact-x child))
  507.         (or y (contact-y child))
  508.         (or width (contact-width child))
  509.         (or height (contact-height child))
  510.         (or border-width (contact-border-width child)))))
  511.  
  512.  
  513.  
  514. (defmethod preferred-size ((self command-sheet) &key width height border-width)
  515.   (declare (ignore width height border-width))
  516.   (with-slots (children) self
  517.     (let
  518.       ((space   (point-pixels
  519.           (contact-screen self)
  520.           (getf *dialog-point-spacing*
  521.             (contact-scale (contact-parent self)))))
  522.        (area    (find :area children :key 'contact-name))
  523.        (control (find :control children :key 'contact-name))
  524.        (footer  (find :footer children :key 'contact-name)))
  525.       
  526.       (multiple-value-bind (area-width area-height) (preferred-size area)
  527.     (multiple-value-bind (control-width control-height) (preferred-size control)
  528.       (multiple-value-bind (footer-width footer-height) (preferred-size footer)
  529.         (declare (ignore footer-width))
  530.         
  531.         (values
  532.           (+ space (max area-width control-width) space)
  533.           (+ 1 space area-height space control-height space footer-height 1)
  534.           0)))))))
  535.  
  536.  
  537. (defmethod resize :after ((self command-sheet) width height border-width)
  538.   (declare (ignore width height border-width))
  539.   (adjust-layout self))
  540.  
  541.